home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / blib.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  30KB  |  1,013 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "libhdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "type.h"
  19. #include "ifile.h"
  20. #include "axqrp.h"
  21. #include "genp.h"
  22. #include "segmentp.h"
  23. #include "ginterp.h"
  24. #include "setp.h"
  25. #include "bmainp.h"
  26. #include "gutilp.h"
  27. #include "dclmapp.h"
  28. #include "libp.h"
  29. #include "libfp.h"
  30. #include "librp.h"
  31. #include "glibp.h"
  32. #include "miscp.h"
  33. #include "gmiscp.h"
  34. #include "smiscp.h"
  35. #include "gnodesp.h"
  36. #include "blibp.h"
  37.  
  38. static void update_elaborate(char *);
  39. static void main_code_segment();
  40. static Tuple delayed_map_get(int);
  41. static void delayed_map_put(int, Tuple);
  42. static void delayed_map_undef(int);
  43. static void add_code(char *);
  44. static int needs_body_bnd(char *);
  45. static int depth_level(char *);
  46. static Tuple build_relay_sets(char *, int);
  47. static void update_subunit_context(char *);
  48. static int load_binding_unit(char *);
  49. static char *read_binding_ais(char *, char *);
  50.  
  51. extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
  52. extern int adacomp_option;
  53. extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
  54. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  55. extern IFILE *AXQFILE, *LIBFILE, *AISFILE, *STUBFILE;
  56.  
  57. /* variables used only by binder */
  58. static Symbol    mainunit_sym;
  59.  
  60. int binder(Tuple aisread_tup)                                    /*;binder*/
  61. {
  62.     /*
  63.      * BINDER checks the program library of a given main program for
  64.      * completeness.  Missing modules are printed.
  65.      * Otherwise, idle_task and main_task are generated. idle_task calls
  66.      * the initialization procedures required to elaborate the various
  67.      * units in (one of) the order(s) prescribed by the language
  68.      */
  69.  
  70.     char    *name, *body, *main_name, *s_name;
  71.     int        prior, unit, name_num, delayed_unit;
  72.     Set        elaborated, idle_precedes, precedes;
  73.     struct unit *pUnit;
  74.     Tuple    missing_units, to_check, to_bind, u_slots, tup;
  75.     Tuple    elaboration_table, compiled_units, delayed, s, u_rs;
  76.     Fortup    ft1;
  77.     Forset    fs1;
  78.     Unitdecl    ud;
  79.     int        i, n;
  80.     int         is_interfaced_bind_unit_now;
  81.  
  82. #ifdef DEBUG
  83.     Tuple       axq_needed; /* list of predefined units */
  84. #endif
  85.  
  86.     /* Reset global tuple of node and symbols for binder. */
  87.     seq_node_n = 0;
  88.     seq_node = tup_new(SEQ_NODE_INC);
  89.     seq_symbol_n = 0;
  90.  
  91.     /*  Miscelleanous variables needed for code generation */
  92.     LOCAL_REFERENCE_MAP =  local_reference_map_new();
  93.     RELAY_SET = tup_new(0);
  94.     /*
  95.      * POSITION and PATCHES is stored in EMAP and is set implicitly when a new
  96.      * EMAP is created for a symbol and therefore is not needed here.
  97.      *
  98.      * POSITION     = {};
  99.      * PATCHES     = {};
  100.      */
  101.     CURRENT_LEVEL = 0;
  102.     LAST_OFFSET     = 0;
  103.     MAX_OFFSET     = 0;
  104.  
  105.     call_lib_unit = tup_new(0);
  106.  
  107.     if (streq(MAINunit, "")) {
  108.         to_check = tup_new(0);
  109.         /* collect all possible main units i.e. all parameterless subprograms
  110.          * which are not proper bodies (subunits).
  111.          */
  112.         for (i = 15; i <= unit_numbers; i++) {
  113.             struct unit *pUnit = pUnits[i];
  114.             if (pUnit->isMain && !streq("ma", unit_name_type(pUnit->name)))
  115.                 to_check = tup_with(to_check,pUnit->name);
  116.         }
  117.         if (tup_size(to_check) == 0) {
  118.             user_error("No subprogram in library");
  119.             return FALSE;
  120.         }
  121.         else if (tup_size(to_check) == 1) {
  122.             main_name = tup_frome(to_check);
  123.             MAINunit  = unit_name_name(main_name);
  124.         }
  125.         else {
  126.             user_error(
  127.                   "Several subprograms in library please specify main from:");
  128.             FORTUP(name = (char *), to_check, ft1);
  129.                 user_info(unit_name_name(name));
  130.             ENDFORTUP(ft1);
  131.             return FALSE;
  132.         }
  133.     }
  134.     else {
  135.         main_name = strjoin("su", MAINunit);
  136.     }
  137.  
  138.     if (!load_binding_unit(main_name)) {
  139.         /* message cannot retrieve... already printed */
  140.         return FALSE;
  141.     }
  142.     update_elaborate(main_name);
  143.     ud = unit_decl_get(main_name);
  144.     mainunit_sym = ud->ud_unam;
  145.     if (NATURE(mainunit_sym) != na_procedure    /* only procedures */
  146.       || tup_size(SIGNATURE(mainunit_sym)) != 0) {    /* without parameters */
  147.         user_error(strjoin(formatted_name(main_name),
  148.           " is not a valid main program."));
  149.         return FALSE;
  150.     }
  151.     name  = strjoin(MAINunit, "_idle_task");
  152.     /* The name of the binding unit is "ma" followed by the name */
  153.     /* In SETL unit_name was ['main_unit', name] */
  154.     /* Note that this may create a new unit */
  155.     unit_name      = strjoin("ma", name);
  156.     unit_number_now  = unit_number(unit_name);
  157.     lib_unit_put(unit_name, AISFILENAME);
  158.  
  159.     /*    Symbol table initialized with 'main_task_type' */
  160.  
  161.     symbol_main_task_type = sym_new(na_task_type);
  162.     TYPE_OF(symbol_main_task_type) = symbol_main_task_type;
  163.     SIGNATURE(symbol_main_task_type) = tup_new(0);
  164.     ALIAS(symbol_main_task_type) = symbol_main_task_type;
  165.     ORIG_NAME(symbol_main_task_type) = "main_task_type";
  166.     DECLARED(symbol_main_task_type) = dcl_new(0);
  167.     TYPE_KIND(symbol_main_task_type) = TK_WORD;
  168.     TYPE_SIZE(symbol_main_task_type) = su_size(TK_WORD);
  169. #ifdef TBSL
  170.     /* REFERENCE_MAP = {['main_task_type', [1, 47]]}; */
  171.     S_SEGMENT(symbol_main_task_type) = 1;
  172.     S_OFFSET(symbol_main_task_type)  = 47;
  173. #endif
  174.     MISC(symbol_main_task_type) = (char *)TRUE;
  175.  
  176.     /* Here we duplicate that part of the code from init_gen needed
  177.      * when starting a new unit
  178.      *
  179.      * Set initial unit_slots map to null value 
  180.      * assume unit_number_now gives curent unit number; the correct
  181.      * assignment of this may best be done elsewhere
  182.      */
  183.     tup = tup_new(5);
  184.     for (i = 1; i <= 5; i++)
  185.         tup[i] = (char *) tup_new(0);
  186.     unit_slots_put(unit_number_now, tup);
  187.     to_check      = tup_new1(main_name);
  188.     idle_precedes  = set_new1((char *) unit_numbered(main_name));
  189.     to_bind      = tup_new(0);
  190.     missing_units  = tup_new(0);
  191.     compiled_units = tup_new(unit_numbers);
  192.     for (i = 1; i <= unit_numbers; i++)
  193.         compiled_units[i] = pUnits[i]->libUnit;
  194.  
  195.     /* check that any needed unit has been compiled. 
  196.      *
  197.      * All units needed (directly or indirectly) by main_name are checked. 
  198.      * The order in which these checks are performed is unimportant. The 
  199.      * ordering map 'precedes' has been loaded from library, for later use 
  200.      * in a topological sort. 
  201.      *
  202.      * All units needed, but not referenced by with clauses (typically 
  203.      * package bodies, procedure bodies and subunits) are noted into 
  204.      * idle_precedes to make later idle_task depend on them, in order to 
  205.      * suppress the binding unit if they are recompiled. 
  206.      */
  207.  
  208.     while (tup_size(to_check)!= 0) {
  209.  
  210.         /* always load the item at the front of the queue so that specs are
  211.          * read before their bodies.
  212.          * TBSL: this is due to the fact that the body sometimes contains
  213.          * info that is not in the spec(e.g. ASSOC_SYMBOLS) and since they share
  214.          * the same symbol the info would be overridden by the spec if the spec 
  215.          * was read last.
  216.          */
  217.         name = tup_fromb(to_check);
  218.         if (is_generic(name))
  219.             continue;
  220.  
  221.         /* Check to see whether a package specification requires a body and
  222.          * if yes, that the body has been compiled.
  223.          */
  224.         if (streq(unit_name_type(name), "sp")
  225.           || streq(unit_name_type(name), "bo")) {
  226.             /* AXQ needed */
  227.             if (!load_binding_unit(name))
  228.                 missing_units = tup_with(missing_units, name);
  229.             else
  230.                 update_elaborate(name);
  231.         }
  232.         /* Collect the stubs of the current unit. */
  233.         s = stubs(name);
  234.         /*
  235.          * to_check      +:= s;
  236.          * missing_units +:= s - compiled_units;  
  237.          * idle_precedes +:= s;
  238.          */
  239.         FORTUP(s_name = (char *), s, ft1);
  240.              if (!tup_memstr(s_name, to_check))
  241.                  to_check = tup_with(to_check, s_name);
  242.              if (!tup_memstr(s_name, compiled_units))
  243.                  missing_units = tup_with(missing_units, s_name);
  244.              idle_precedes = set_with(idle_precedes,
  245.                (char *) unit_numbered(s_name));
  246.         ENDFORTUP(ft1);
  247.  
  248.         if (streq(unit_name_type(name), "sp")) {
  249.             body = strjoin("bo", unit_name_name(name));
  250.             if (tup_memstr(body, compiled_units)) {
  251.                 to_check = tup_with(to_check, body);
  252.                 idle_precedes = set_with(idle_precedes,
  253.                   (char *)unit_numbered(body));
  254.             }
  255.             else if (needs_body_bnd(name))
  256.                 missing_units = tup_with(missing_units, body);
  257.         }
  258.         else if (streq(unit_name_type(name), "ss")) {
  259.             /* Suprogram body must be present.*/
  260.             body = strjoin("su", unit_name_name(name));
  261.             if (tup_memstr(body, compiled_units) && load_binding_unit(body)) {
  262.                 to_check = tup_with(to_check, body);
  263.                 update_elaborate(body);
  264.             }
  265.             else
  266.                 missing_units = tup_with(missing_units, body);
  267.             idle_precedes = set_with(idle_precedes,
  268.               (char *) unit_numbered(body));
  269.         }
  270.  
  271.         else if (streq(unit_name_type(name), "su")) {
  272.             if (is_subunit(name)) {     /* no previous unit spec, of course. */
  273.                 if (load_binding_unit(name))
  274.                     update_elaborate(name);
  275.             }
  276.             else if (!tup_memstr(name, compiled_units))   /* no previous spec */
  277.                 missing_units = tup_with(missing_units, name);
  278.         }
  279.  
  280.         /* Check the units indicated by visibility lists (precedes).
  281.          *  
  282.          * loop forall prior in precedes{name} | prior notin to_bind do
  283.          *    to_check with= prior;
  284.          * end loop forall;
  285.          */
  286.         precedes = precedes_map_get(name);
  287.         FORSET(prior = (int), precedes, fs1);
  288.              if (!tup_memstr(pUnits[prior]->name, to_bind))
  289.                  to_check = tup_with(to_check, pUnits[prior]->name);
  290.         ENDFORSET(fs1);
  291.  
  292.         if (is_subunit(name) && tup_memstr(name, compiled_units))
  293.             update_subunit_context(name);
  294.  
  295.         to_bind = tup_with(to_bind, name);
  296.  
  297.     } /* end while */
  298.  
  299.     /* If compilation units are missing, report them and return. */
  300.  
  301.     if (tup_size(missing_units) != 0) {
  302.         user_error("Missing units in library:");
  303.         FORTUP(name = (char *), missing_units, ft1);
  304.             user_info(formatted_name(name));
  305.         ENDFORTUP(ft1);
  306.         return FALSE;
  307.     }
  308.     if (tup_size(interfaced_procedures) != 0) {
  309.         int i, j, n, m;
  310.         n = tup_size(interfaced_procedures);
  311.         m = tup_size(to_bind);
  312.         for (i = 1; i <= n; i += 2) {
  313.             for (j = 1; j <= m; j++) {
  314.                 if((int)interfaced_procedures[i] == unit_numbered(to_bind[j])) {
  315.                     /* the field of is_main which is usualy always 0 for a
  316.                      * binding unit is set to 1 in this case to specify that
  317.                      * this binding unit calls an interfaced subprogram
  318.                      */
  319.                     pUnits[unit_number_now]->isMain = 1;
  320.                     is_interfaced_bind_unit_now = 1;
  321.                     break;
  322.                 }
  323.                 else {
  324.                     is_interfaced_bind_unit_now = 0;
  325.                 }
  326.             }
  327.         }
  328.     }
  329.     else {
  330.         is_interfaced_bind_unit_now = 0;
  331.     }
  332.  
  333.     if (is_interfaced_bind_unit_now) geninter(to_bind);
  334.     /*
  335.      * call_lib_unit is built in an order consistent with the rules for 
  336.      * the elaboration of library units. 
  337.      * The algorithm tries to use the compilation order, unless some unit 
  338.      * depends on a not yet elaborated unit. In that case, it is appended 
  339.      * to a list of units depending on one of the not yet elaborated units 
  340.      * When this unit is elaborated, one tries again to elaborate units 
  341.      * depending on it. 
  342.      * If a unit depends on one of its own delayed units, it is a 
  343.      * circularity 
  344.      * elaborated: set of already elaborated units 
  345.      * delayed     : map from units to the list of dependant units. 
  346.      */
  347.  
  348.     /* Use the compilation order */
  349.     /* TBSL: for now we elaborate all units even if we don't use them.
  350.      * a better scheme is to have elaboration_table be only units we need.
  351.      */
  352.     elaboration_table = tup_copy(compilation_table);
  353.     elaborated         = set_new1((char *)0);
  354.     DELAYED_MAP      = tup_new(0);
  355. #ifdef DEBUG
  356.     axq_needed        = tup_new(0);
  357. #endif
  358.  
  359.     while (tup_size(elaboration_table) != 0) {
  360.         name_num = (int) tup_fromb(elaboration_table);
  361.         name = pUnits[name_num]->name;
  362.  
  363.         if (is_generic(name) || is_subunit(name)) {
  364.             /* Generics are not elaborated 
  365.              * subunits are elaborated from the parent 
  366.              */
  367.             elaborated = set_with(elaborated, (char *) name_num);
  368.         }
  369.         else if (!tup_memstr(name, to_bind)) {
  370.             /* Don't need this unit */
  371.         }
  372.         else if (set_subset(precedes_map_get(name), elaborated)) {
  373.             /* May elaborate this unit now */
  374.             add_code(name);
  375.             elaborated = set_with(elaborated, (char *) name_num);
  376. #ifdef TBSL
  377.             if (name_num < 11) { /* predef unit */
  378. #endif
  379.             /*
  380.              * if (name in domain delayed) then 
  381.              * -- Retry units depending on this one 
  382.              *   elaboration_table := delayed(name) + elaboration_table;
  383.              *   delayed(name) := OM;
  384.              * end if;
  385.              */
  386.             n = tup_size(DELAYED_MAP);
  387.             for (i = 1; i <= n; i += 2) {
  388.                 if (DELAYED_MAP[i] == (char *)name_num) {
  389.                     /* Retry units depending on this one */
  390.                     elaboration_table=
  391.                       tup_add(delayed_map_get(name_num), elaboration_table);
  392.                     delayed_map_undef(name_num);
  393.                     break;
  394.                 }
  395.             }
  396.         }
  397.         else {
  398.             /* Depends on a not yet elaborated unit => delay elaboration */
  399.             precedes = precedes_map_get(name);
  400.             unit     = (int) set_arb(set_diff(precedes, elaborated));
  401.             /* delayed(unit) = (delayed(unit) ? []) with name; */
  402.             delayed = delayed_map_get(unit);
  403.             if (delayed == (Tuple)0)
  404.                 delayed_map_put(unit, tup_new1((char *) name_num));
  405.             else
  406.                 delayed_map_put(unit, tup_with(delayed, (char *)name_num));
  407.             /* TBSL: This code to be removed when predef is handled correctly */
  408.             if (name_num < num_predef_units) {
  409.                 elaboration_table =
  410.                   tup_add(tup_new1((char *)unit), elaboration_table);
  411.             }
  412.         }
  413.     } /* end while */
  414.  
  415.     /* Check for circularity among units */
  416.     n = tup_size(DELAYED_MAP);
  417.     if (n != 0) {
  418.         user_error("Circularity detected among these units:");
  419.         for (i = 1; i <= n; i += 2) {
  420.             delayed = (Tuple) DELAYED_MAP[i+1];
  421.             FORTUP(delayed_unit = (int), delayed, ft1);
  422.                 user_info(formatted_name(pUnits[delayed_unit]->name));
  423.             ENDFORTUP(ft1);
  424.         }
  425.         return FALSE;
  426.     }
  427.  
  428.     /* Everything is OK: build idle and main task */
  429.  
  430. #ifdef TBSL
  431.     axqfiles_read = tup_with(axqfiles_read, AXQfile);
  432.     aisread_tup(1)    with= unit_name;
  433. #endif
  434.  
  435.     CURRENT_DATA_SEGMENT = 1;
  436.     CURRENT_CODE_SEGMENT = 1;
  437. #ifdef MACHINE_CODE
  438.     if (list_code) {
  439.         to_gen(" ");
  440.         to_gen(" ");
  441.         to_gen_unam("============== UNIT : ", formatted_name(unit_name),
  442.           " ==============");
  443.         to_gen(" ");
  444.         to_gen("--- Idle task ---");
  445.         to_gen_int("    data slot # ", CURRENT_DATA_SEGMENT);
  446.         to_gen_int("    code slot # ", CURRENT_CODE_SEGMENT);
  447.         to_gen(" ");
  448.     }
  449. #endif
  450.     u_slots = tup_new(5);
  451. #ifdef DEBUG
  452.     if(tup_size(axq_needed)) { /* binding requiring predef data segments */
  453.         tup = read_predef_axq(axq_needed);
  454.         u_slots[SLOTS_DATA] = (char *)tup_with((Tuple) tup[1],
  455.           (char *)CURRENT_DATA_SEGMENT);
  456.         u_slots[SLOTS_CODE] = (char *)tup_with((Tuple) tup[2],
  457.           (char *)CURRENT_CODE_SEGMENT);
  458.     }
  459.     else { /* library option or no predefined unit needed */
  460.         u_slots[SLOTS_DATA] = (char *)tup_new1((char *)CURRENT_DATA_SEGMENT);
  461.         u_slots[SLOTS_CODE] = (char *)tup_new1((char *)CURRENT_CODE_SEGMENT);
  462.     }
  463. #else
  464.     u_slots[SLOTS_DATA] = (char *)tup_new1((char *)CURRENT_DATA_SEGMENT);
  465.     u_slots[SLOTS_CODE] = (char *)tup_new1((char *)CURRENT_CODE_SEGMENT);
  466. #endif
  467.     u_slots[SLOTS_EXCEPTION] = (char *)tup_new(0);
  468.     u_slots[SLOTS_DATA_BORROWED] = (char *)tup_new(0);
  469.     u_slots[SLOTS_CODE_BORROWED] = (char *)tup_new(0);
  470.     unit_slots_put(unit_number_now, u_slots);
  471.  
  472.     precedes_map_put(unit_name, idle_precedes);
  473.  
  474.     DATA_SEGMENT = DATA_SEGMENT_MAIN;
  475.  
  476.     /* Compute the relay sets of subunits: 
  477.      *
  478.      * loop forall name in to_bind | not is_subunit(name) do
  479.      *  [-, u_rs] = build_relay_sets(name, 1);
  480.      *  if (u_rs !== []) then 
  481.      *     COMPILER_ERROR ("Relay set at level 1 in "+formatted_name(name));
  482.      *    if debug_flag then
  483.      *       gen_trace("BINDER", u_rs);
  484.      *    end if;
  485.      *  end if;
  486.      * end loop;
  487.      */
  488.  
  489.     FORTUP(name = (char *), to_bind, ft1);
  490.         if (!is_subunit(name)) {
  491.             tup = build_relay_sets(name, 1);
  492.             u_rs = (Tuple) tup[2];
  493.             if (tup_size(u_rs) != 0) {
  494.                 compiler_error (
  495.                   strjoin("Relay set at level 1 in ", formatted_name(name)));
  496.             }
  497.         }
  498.     ENDFORTUP(ft1);
  499.  
  500.     main_code_segment();
  501.     /* Update library */
  502.  
  503.     /* OWNED_SLOTS(unit_name)(2) with= CURRENT_CODE_SEGMENT; */
  504.     u_slots[SLOTS_CODE] = (char *)tup_with((Tuple) u_slots[SLOTS_CODE],
  505.       (char *)CURRENT_CODE_SEGMENT);
  506.  
  507. #ifdef TBSL
  508.     LIB_UNIT (unit_name) = [NODE_COUNT, '' , AXQfile]
  509.        + OWNED_SLOTS(unit_name);
  510.     PRE_COMP (unit_name) = idle_precedes;
  511.     COMP_DATE(unit_name) = {
  512. [name, COMP_DATE(name)(name)] :
  513.         name in idle_precedes * compiled_units        };
  514.     today = DATE;
  515.     COMP_DATE(unit_name)(unit_name) =
  516.         [today(9..17), today(20..27), #aisread_tup(1)];
  517. #endif
  518.  
  519.     /* DATA_SEGMENT_MAP(CURRENT_DATA_SEGMENT) = DATA_SEGMENT; */
  520.     DATA_SEGMENT_MAP = 
  521.       segment_map_put(DATA_SEGMENT_MAP, CURRENT_DATA_SEGMENT, DATA_SEGMENT);
  522.  
  523.     compilation_table = tup_with(compilation_table, (char *)unit_number_now);
  524.     pUnit = pUnits[unit_number_now];
  525.     pUnit->aisInfo.numberSymbols = seq_symbol_n;
  526.     pUnit->aisInfo.symbols = (char *) tup_new(seq_symbol_n);
  527. #ifdef MACHINE_CODE
  528.     if (list_code) print_data_segment();
  529. #endif
  530.     return TRUE;
  531. }
  532.  
  533. static void update_elaborate(char *name)                /*;update_elaborate*/
  534. {
  535.     Set      precedes;
  536.     Tuple  pragma_tup;
  537.     char      *unam;
  538.     int      unit, name_num;
  539.     Fortup ft1;
  540.  
  541.     name_num = unit_numbered(name);
  542.     pragma_tup = (Tuple) pUnits[name_num]->aisInfo.pragmaElab;
  543.     precedes = (Set) precedes_map_get(name);
  544.     FORTUP(unam = (char *), pragma_tup, ft1);
  545.         unit = unit_numbered(unam);
  546.         /* if the pragma names a unit which is not explicitly present (unit is 0
  547.          * or the body may be obsolete) ignore it
  548.          */
  549.         if (unit != 0) {
  550.             if (streq(pUnits[unit]->libInfo.obsolete, "ok"))
  551.                 precedes = set_with(precedes, (char *) unit);
  552.         }
  553.     ENDFORTUP(ft1);
  554.     precedes_map_put(name, precedes);
  555. }
  556.  
  557. static void main_code_segment()                        /*;main_code_segment */
  558. {
  559.     Node  call_node;
  560.     Symbol      loop_name;
  561.     Segment    task_id;
  562.     Symbol     handler1, handler2, handler3;
  563.     Fortup    ft1;
  564.  
  565.     /* check that symbol_main_task_type defined */
  566.     if (symbol_main_task_type == (Symbol)0)
  567.         chaos("glib.c main_code_segment  symbol_main_task_type not defined");
  568.  
  569.     CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
  570.     gen_c(I_NOP, "no handling; go to task trap");
  571.     gen(I_NOP);
  572.     gen_ic(I_TERMINATE, 6, "task trap in case of dead-lock");
  573.  
  574.     symbol_main_task = sym_new(na_obj);
  575.     ORIG_NAME(symbol_main_task) = strjoin("main_task", "");
  576.     new_symbol(symbol_main_task, na_obj, symbol_main_task_type, (Tuple)0,
  577.       (Symbol)0);
  578.     task_id = segment_new(SEGMENT_KIND_DATA, 1);
  579.     segment_put_word(task_id, 0);
  580.     next_global_reference_segment(symbol_main_task, task_id);
  581.     gen(I_ENTER_BLOCK);
  582.     gen_s(I_CREATE_TASK, symbol_main_task_type);
  583.     gen_ks(I_POP, kind_of(symbol_main_task_type), symbol_main_task);
  584.     gen(I_ACTIVATE);
  585.     loop_name = new_unique_name("endless_loop");
  586.     gen_s(I_LABEL, loop_name);
  587.     gen_s(I_JUMP, loop_name);
  588.     gen(I_EXIT_BLOCK);
  589.     gen(I_END);         /* flush peep-hole buffer */
  590.  
  591.     /*CODE_SEGMENT_MAP(CURRENT_CODE_SEGMENT) = CODE_SEGMENT;*/
  592.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  593.       CODE_SEGMENT);
  594.  
  595.     CURRENT_CODE_SEGMENT = MAIN_CS;
  596. #ifdef MACHINE_CODE
  597.     if (list_code) {
  598.         to_gen(" ");
  599.         to_gen(" ");
  600.         to_gen("--- Main task ---");
  601.         to_gen_int("       code slot # ", CURRENT_CODE_SEGMENT);
  602.         to_gen(" ");
  603.     }
  604. #endif
  605.     CODE_SEGMENT = segment_new(SEGMENT_KIND_CODE, 0);
  606.     gen(I_LEAVE_BLOCK);
  607.     gen(I_RAISE);
  608.     gen_ic(I_TERMINATE, 5, "never used");
  609.     gen(I_ENTER_BLOCK);
  610.     gen_ic(I_END_ACTIVATION, 1, "Ok");
  611.     handler1 = new_unique_name("handler");
  612.     gen_s(I_INSTALL_HANDLER, handler1);
  613.     gen(I_ENTER_BLOCK);
  614.     FORTUP(call_node = (Node), call_lib_unit, ft1);
  615.         if (N_KIND(call_node) == as_activate_spec) {
  616.             gen_ks(I_PUSH, mu_word, N_UNQ(N_AST1(call_node)));
  617.             gen(I_LINK_TASKS_DECLARED);
  618.             gen(I_ACTIVATE);
  619.         }
  620.         else {
  621.             gen_s(I_CALL, N_UNQ(N_AST1(call_node)));
  622.         }
  623.     ENDFORTUP(ft1);
  624.     handler2 = new_unique_name("handler");
  625.     gen_s(I_INSTALL_HANDLER, handler2);
  626.     gen_s(I_CALL, mainunit_sym);
  627.     gen(I_EXIT_BLOCK);
  628.     handler3 = new_unique_name("end_handler");
  629.     gen_s(I_JUMP, handler3);
  630.     gen_s(I_LABEL, handler2);
  631.     gen_ic(I_TERMINATE, 4, "unhandled exception in main");
  632.     gen_s(I_LABEL, handler3);
  633.     gen(I_EXIT_BLOCK);
  634.     handler3 = new_unique_name("end_handler");
  635.     gen_s(I_JUMP, handler3);
  636.     gen_s(I_LABEL, handler1);
  637.     gen_ic(I_TERMINATE, 3, "exception in library unit elaboration");
  638.     gen_s(I_LABEL, handler3);
  639.     gen_ic(I_TERMINATE, 5, "library tasks are completed");
  640.     gen_ic(I_DATA, 0, "size of local objects");
  641.     gen(I_END);         /* flush peep-hole buffer */
  642.  
  643.     /*CODE_SEGMENT_MAP(CURRENT_CODE_SEGMENT) = CODE_SEGMENT;*/
  644.     CODE_SEGMENT_MAP = segment_map_put(CODE_SEGMENT_MAP, CURRENT_CODE_SEGMENT,
  645.       CODE_SEGMENT);
  646. }
  647.  
  648. static Tuple delayed_map_get(int unum)                    /*;delayed_map_get*/
  649. {
  650.     int        i, n;
  651.  
  652.     n = tup_size(DELAYED_MAP);
  653.     for (i = 1; i <= n; i += 2) {
  654.         if (DELAYED_MAP[i] == (char *)unum)
  655.             return (Tuple) DELAYED_MAP[i+1];
  656.     }
  657.     return (Tuple)0;
  658. }
  659.  
  660. static int needs_body_bnd(char *name)                            /*;needs_body */
  661. {
  662.     Unitdecl ud;
  663.     Tuple   tup;
  664.     Symbol  unit_unam;
  665.  
  666.     ud = unit_decl_get(name);
  667.     /* A spec which is obsolete needs no body */
  668.     if (ud == (Unitdecl)0) return FALSE;
  669.     unit_unam = ud->ud_unam;
  670.     tup = (Tuple) MISC(unit_unam);
  671.     return ((int)tup[2] != 0);
  672. }
  673.  
  674. static void delayed_map_put(int unum, Tuple ntup)            /*;delayed_map_put*/
  675. {
  676.     int        i, n;
  677.  
  678.     n = tup_size(DELAYED_MAP);
  679.     for (i = 1; i <= n; i += 2) {
  680.         if (DELAYED_MAP[i] == (char *) unum) {
  681.             DELAYED_MAP[i+1] = (char *) ntup;
  682.             return;
  683.         }
  684.     }
  685.     DELAYED_MAP = tup_exp(DELAYED_MAP, n + 2);
  686.     DELAYED_MAP[n+1] = (char *) unum;
  687.     DELAYED_MAP[n+2] = (char *) ntup;
  688. }
  689.  
  690. static void delayed_map_undef(int unum)                    /*;delayed_map_undef*/
  691. {
  692.     int    i, n;
  693.  
  694.     n = tup_size(DELAYED_MAP);
  695.     for (i = 1; i <= n; i += 2) {
  696.         if (DELAYED_MAP[i] == (char *) unum) {
  697.             DELAYED_MAP[i] = DELAYED_MAP[n-1];
  698.             DELAYED_MAP[i+1] = DELAYED_MAP[n];
  699.             DELAYED_MAP[0] = (char *) (n-2);
  700.             return;
  701.         }
  702.     }
  703. }
  704.  
  705. static void add_code(char *name)                                /*;add_code*/
  706. {
  707.     /*
  708.      * Adds to call_lib_unit the calls required to elaborate packages.
  709.      * Library subprograms never need elaboration.
  710.      * Subunits are elaborated in the parent unit at the location of the
  711.      * correponding stub.
  712.      */
  713.  
  714.     Unitdecl    ud;
  715.     Symbol    unit_unam;
  716.     Node        act_node;
  717.     char        *unit_kind, *body;
  718.     int            has_body, i;
  719.     /* Late generic instantiations : TBSL */
  720.  
  721.     unit_kind = unit_name_type(name);
  722.     /* elaboration only needed for packages */
  723.     if (!streq(unit_kind, "sp") && !streq(unit_kind, "bo")) return;
  724.  
  725.     ud = unit_decl_get(name);
  726.     unit_unam = ud->ud_unam;
  727.  
  728.     if (streq(unit_kind, "sp")) {
  729.         call_lib_unit = tup_with(call_lib_unit, (char *) new_call_node(
  730.           assoc_symbol_get(unit_unam, INIT_SPEC), tup_new(0), symbol_none));
  731.         body = strjoin("bo", unit_name_name(name));
  732.         has_body = FALSE;
  733.         for (i = 1; i <= unit_numbers; i++)
  734.             if (streq(body, pUnits[i]->name)) {
  735.                 has_body = TRUE;
  736.                 break;
  737.             }
  738.         if (lib_package_with_tasks(unit_unam)    /* spec declares tasks */
  739.           && !has_body) {        /* but has no body */
  740.             act_node = new_node(as_activate_spec);
  741.             N_AST1(act_node) = new_name_node(assoc_symbol_get(unit_unam,
  742.               INIT_TASKS));
  743.             call_lib_unit = tup_with(call_lib_unit, (char *) act_node);
  744.         }
  745.     }
  746.     else if (streq(unit_kind, "bo")) {
  747.         call_lib_unit = tup_with(call_lib_unit, (char *) new_call_node(
  748.           assoc_symbol_get(unit_unam, INIT_BODY), tup_new(0), symbol_none));
  749.     }
  750. }
  751.  
  752. static int depth_level(char *stub_name)                        /*;depth_level*/
  753. {
  754.     /* calculate the current nesting depth of the subunit by trailing down its
  755.      * parent chain until its ancestor os reached.
  756.      */
  757.  
  758.     int        level, parent;
  759.     char    *s_name;
  760.  
  761.     level = 1;
  762.     s_name = stub_name;
  763.     while (1) {
  764.         parent = stub_parent_get(s_name);
  765.         if (parent != 0) {
  766.             s_name = pUnits[parent]->name;
  767.             level++;
  768.         }
  769.         else {
  770.             break;
  771.         }
  772.     }
  773.     return level;
  774. }
  775.  
  776. static Tuple build_relay_sets(char *unit, int depth)    /*;build_relay_sets*/
  777. {
  778.     /*
  779.      * This procedure computes the relay sets for the subunits of unit.
  780.      * Yield the relay tables of all (direct or indirect) subunits of unit.
  781.      * Depth is the level of imbrication ofsubunits (1 if unit is not a
  782.      * subunit).
  783.      * u_xxx stands for unit xxx
  784.      * s_xxx stands for subunit xxx
  785.      * sl     stands for (relay) slot
  786.      * rs     stands for relay set
  787.      */
  788.  
  789.     Tuple    save_relay_set, save_local_reference_map;
  790.     Tuple    s_rs, u_rs, stubs_tup, s_table, return_tup;
  791.     Tuple    stubtup, tup;
  792.     Stubenv    ev;
  793.     struct unit *pUnit;
  794.     int        u_sl, s_sl, offset, seg_num, si;
  795.     Symbol    name;
  796.     Fortup    ft1, ft2;
  797.     char        *s_name;
  798.  
  799.     /******
  800.    save_local_reference_map = LOCAL_REFERENCE_MAP;
  801.    save_relay_set        = RELAY_SET;
  802.  
  803.    [-,-,-,-,-,-,[u_sl,LOCAL_REFERENCE_MAP]] = LIB_UNIT(unit);
  804.    if (is_subunit(unit)) {
  805.         [-,-,-,-,-,-,-,RELAY_SET,DANGLING_RELAY_SETS] = STUB_ENV(unit);
  806.         DATA_SEGMENT += DANGLING_RELAY_SETS;
  807.    }
  808.    else {
  809.         RELAY_SET = [];
  810.    }
  811.     ********/
  812.  
  813.     save_local_reference_map = tup_copy(LOCAL_REFERENCE_MAP);
  814.     save_relay_set        = tup_copy(RELAY_SET);
  815.  
  816.     pUnit = pUnits[unit_numbered(unit)];
  817.     u_sl = (int)pUnit->libInfo.currCodeSeg;
  818.     LOCAL_REFERENCE_MAP = tup_copy((Tuple) pUnit->libInfo.localRefMap);
  819.  
  820.     if (is_subunit(unit) && !is_generic(unit)) {
  821.         si = stub_numbered(unit);
  822.         stubtup = (Tuple) stub_info[si];
  823.         ev = (Stubenv) stubtup[2];
  824.         RELAY_SET = tup_copy(ev->ev_relay_set);
  825.         DANGLING_RELAY_SETS = tup_copy(ev->ev_dangling_relay_set);
  826.         FORTUP(seg_num = (int), DANGLING_RELAY_SETS, ft1);
  827.         segment_put_int(DATA_SEGMENT, seg_num);
  828.         ENDFORTUP(ft1);
  829.     }
  830.     else {
  831.         RELAY_SET = tup_new(0);
  832.     }
  833.     /******
  834.    loop forall s_name in stubs(unit) | #s_name = depth+2 do
  835.     [s_sl, s_rs]   = build_relay_sets(s_name, depth+1);
  836.     s_table        = [reference_of(name)(2): name in s_rs];
  837.     DATA_SEGMENT += [s_sl, #s_table] + s_table;
  838.    end loop;
  839.     *****/
  840.  
  841.     stubs_tup = stubs(unit);
  842.     FORTUP(s_name = (char *), stubs_tup, ft1);
  843.         if (depth_level(s_name) != depth+1) continue;
  844.         tup = build_relay_sets(s_name, depth+1);
  845.         s_sl = (int) tup[1];
  846.         s_rs = (Tuple) tup[2];
  847.         s_table = tup_new(0);
  848.         FORTUP(name = (Symbol), s_rs, ft2);
  849.             reference_of(name);
  850.             s_table = tup_with(s_table, (char *) REFERENCE_OFFSET);
  851.         ENDFORTUP(ft2);
  852.         segment_put_int(DATA_SEGMENT, s_sl);
  853.         segment_put_int(DATA_SEGMENT, tup_size(s_table));
  854.         FORTUP(offset = (int), s_table, ft2);
  855.             segment_put_int(DATA_SEGMENT, offset);
  856.         ENDFORTUP(ft2);
  857.     ENDFORTUP(ft1);
  858.     /******
  859.    u_rs               = RELAY_SET;
  860.    RELAY_SET           = save_relay_set;
  861.    LOCAL_REFERENCE_MAP = save_local_reference_map;
  862.    return [u_sl, u_rs];
  863.     *****/
  864.     u_rs         = tup_copy(RELAY_SET);
  865.     RELAY_SET         = save_relay_set;
  866.     LOCAL_REFERENCE_MAP     = save_local_reference_map;
  867.     return_tup = tup_new(2);
  868.     return_tup[1] = (char *) u_sl;
  869.     return_tup[2] = (char *) u_rs;
  870.     return return_tup;
  871. }
  872.  
  873. static void update_subunit_context(char *subunit)    /*;update_subunit_context*/
  874. {
  875.     Set        stub_context, precedes;
  876.     char        *ancestor_body;
  877.     int        ancestor_num, unum, subunit_num;
  878.     Forset    fs1;
  879.     int        has_ancestor, i;
  880.  
  881.     /* Add the library units mentioned in the context clause for the subunit
  882.      * to the precedes map for the ancestor unit of the stub since all the units
  883.      * in the context clause need to be elaborated before the ancestor.
  884.      */
  885.  
  886.     subunit_num = unit_numbered(subunit);
  887.     stub_context = precedes_map_get(subunit);
  888.     /* if the unit has not been loaded return */
  889.     if (stub_context == (Set)0) return;
  890.     ancestor_body = strjoin("bo", stub_ancestor(subunit));
  891.     /* determine if the ancestor unit is package or subprogram */
  892.     has_ancestor = FALSE;
  893.     for (i = 1; i <= unit_numbers; i++)
  894.         if (streq(ancestor_body, pUnits[i]->libUnit)) {
  895.             has_ancestor = TRUE;
  896.             break;
  897.         }
  898.     if (!has_ancestor)
  899.         ancestor_body = strjoin("su", stub_ancestor(subunit));
  900.     ancestor_num = unit_numbered(ancestor_body);
  901.     precedes = precedes_map_get(ancestor_body);
  902.     FORSET(unum = (int), stub_context, fs1);
  903.         /* add in units that were in context clause of subunit so exclude
  904.          * subunits which happen to be in the PRE_COMP field of this subunit.
  905.          */
  906.         if (!is_subunit(pUnits[unum]->name) && unum != ancestor_num)
  907.             precedes = set_with(precedes, (char *)unum);
  908.     ENDFORSET(fs1);
  909.     precedes_map_put(ancestor_body, precedes);
  910. }
  911.  
  912. static int load_binding_unit(char *unit)                /*;load_binding_unit*/
  913. {
  914.     char    *fname;
  915.     int        file_retrieved;
  916.     Unitdecl    ud;
  917.     /* When binding is done load the necessary units if they are not loaded 
  918.      * already. However, when a unit is to be loaded use read_binding_ais so 
  919.      * that only the absolute necessary components of the ais are read.
  920.      */
  921.     fname = lib_unit_get(unit);
  922.     if (fname == (char *)0) {
  923.         user_error(strjoin(formatted_name(unit), " not present in library"));
  924.         return FALSE;
  925.     }
  926.     else if (in_aisunits_read(unit)) {
  927.         file_retrieved = TRUE;
  928.     }
  929.     else {
  930.         file_retrieved = (read_binding_ais(fname, unit) != (char *)0);
  931.         if (is_subunit(unit)) read_stub(lib_unit_get(unit), unit, "st2");
  932.     }
  933.  
  934.     if (file_retrieved && (ud = unit_decl_get(unit)) != (Unitdecl)0) {
  935.         return TRUE;
  936.     }
  937.     else {
  938.         user_error(strjoin("Cannot retrieve unit ", formatted_name(unit)));
  939.         user_info(strjoin(" from file ", fname));
  940.         return FALSE;
  941.     }
  942. }
  943.  
  944. static char *read_binding_ais(char *fname, char *uname)  /*;read_binding_ais*/
  945. {
  946.     long    rec, genoff;
  947.     int        fnum, unum, n, nodes, symbols, i, is_main_unit;
  948.     Tuple    symptr, tup;
  949.     struct unit *pUnit;
  950.     char    *funame, *retrieved ;
  951.     Unitdecl    ud;
  952.     IFILE    *ifile;
  953.     Symbol    sym;
  954.     char     *lname, *tname;
  955.     int        is_predef; /* set when reading predef file */
  956.  
  957.     /* This is a modified version of read_ais, which reads only the neccesary
  958.      * items needed for binding. All other information is skipped.
  959.      */
  960.  
  961.     retrieved = (char *)0;
  962.     is_predef = streq(fname, "0");
  963.     if (is_predef) {
  964.         fname = "predef" ;
  965.         lname= libset(PREDEFNAME);/* use predefined library */
  966.     }
  967.     ifile = ifopen(fname, "axq", "r", 0);
  968.     if (is_predef) {
  969.         tname= libset(lname); /* restore library name */
  970.     }
  971.     for (rec = read_init(ifile); rec != 0; rec = read_next(ifile, rec)) {
  972.         funame = getstr(ifile, "unit-name");
  973.         if (uname != (char *)0  && streq(uname, funame) == 0) continue;
  974.         fnum = getnum(ifile, "unit-number");
  975.         unum = unit_number(funame);
  976.         if (unum != fnum)
  977.             chaos("read_ais sequence number error");
  978.         genoff = getlong(ifile, "code-gen-offset");
  979.         is_main_unit = streq(unit_name_type(funame), "ma");
  980.         if (!is_main_unit) { /* read only if NOT main unit (it has no ais info*/
  981.             symbols = getnum(ifile, "seq-symbol-n");
  982.             nodes = getnum(ifile, "seq-node-n");
  983.             pUnit = pUnits[unum];
  984.             symptr = (Tuple)pUnit->aisInfo.symbols;
  985.             if (symptr == (Tuple)0) { /* if tuple not yet allocated */
  986.                 symptr = tup_new(symbols);
  987.                 pUnit->aisInfo.symbols = (char *) symptr;
  988.             }
  989.  
  990.             /* ELABORATE PRAGMA INFO */
  991.             n = getnum(ifile, "pragma-info-size");
  992.             tup = tup_new(n);
  993.             for (i = 1; i <= n; i++) {
  994.                 tup[i] = getstr(ifile, "pragma-info-value");
  995.             }
  996.             pUnit->aisInfo.pragmaElab = (char *)tup;
  997.             /* UNIT_DECL */
  998.             ud = unit_decl_new();
  999.             pUnit->aisInfo.unitDecl = (char *)ud;
  1000.             sym = getsym(ifile, "ud-unam");
  1001.             ud->ud_unam = sym;
  1002.             ud->ud_useq = S_SEQ(sym);
  1003.             ud->ud_unit = S_UNIT(sym);
  1004.             get_unit_unam(ifile, sym);
  1005.             aisunits_read = tup_with(aisunits_read, funame);
  1006.         }
  1007.         retrieved = funame;
  1008.         break;
  1009.     }
  1010.     ifclose(ifile);
  1011.     return retrieved;
  1012. }
  1013.